unit Unit3;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, WinCrypt;

type
  TForm3 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    ComboBox1: TComboBox;
    Label4: TLabel;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form3: TForm3;
  Dir: String;

implementation

uses Unit4;

{$R *.dfm}

function GenKeysPair(Pub:TMemoryStream; Pair:TMemoryStream; Password:PChar; kLen:DWORD):BOOL;
var
  RSA:HCRYPTPROV;
  Key:HCRYPTKEY;
  expKey:HCRYPTKEY;
  Hash:HCRYPTHASH;
  bRes:BOOL;
  dwLen:DWORD;
  //Param:DWORD;
begin
  result:=true;
  bRes:=CryptAcquireContext(
        @RSA,                 // returned crypto-provider handle.
        nil,                  // use default key container.
        nil,                  // use default CSP (Cryptographic Service Provider).
        PROV_RSA_FULL,        // MS RSA provider (presents by default).
        0                     // no special action.
    );
  if GetLastError=Cardinal(NTE_BAD_KEYSET) then
  bRes:=CryptAcquireContext(
        @RSA,
        nil,
        nil,
        PROV_RSA_FULL,
        CRYPT_NEWKEYSET       // make new keyset
    );
  if not bRes then
  begin
    ShowMessage('CryptAcquireContext failed: '+ SysErrorMessage(GetLastError));
    result:=false;
  end;

  bRes:=CryptGenKey(
        RSA,                  // CSP handle
        AT_KEYEXCHANGE,       // RSA algotrythm
        {kLen}1024 shl 16 or CRYPT_EXPORTABLE,          // length 1 kbit
        @Key                  // Key handle
    );
  if not bRes then
  begin
    ShowMessage('CryptGenKey RSA failed: '+ SysErrorMessage(GetLastError));
    result:=false;
  end;

  bRes:=CryptExportKey(
        Key,
        0,
        PUBLICKEYBLOB,
        0,
        nil,
        @dwLen
    );
  if not bRes then
  begin
    ShowMessage('Computing public blob length failed: '+ SysErrorMessage(GetLastError));
    result:=false;
  end;

  Pub.SetSize(dwLen);
  bRes:=CryptExportKey(
        Key,
        0,
        PUBLICKEYBLOB,
        0,
        PByte(Pub.Memory),
        @dwLen
    );
  if not bRes then
  begin
    ShowMessage('CryptExportKey public failed: '+ SysErrorMessage(GetLastError));
    result:=false;
  end;

  CryptCreateHash(RSA,CALG_SHA,0,0,@Hash);
  CryptHashData(Hash,PByte(Password),lstrlen(Password),0);
  CryptDeriveKey(RSA,CALG_RC4,Hash,0{CRYPT_EXPORTABLE},@expKey);
  //CryptSetKeyParam(expKey,KP_MODE,@Param,0);
  CryptDestroyHash(Hash);

  bRes:=CryptExportKey(
        Key,
        expKey,
        PRIVATEKEYBLOB,
        0,
        nil,
        @dwLen
    );
  if not bRes then
  begin
    ShowMessage('Computing private blob length failed: '+ SysErrorMessage(GetLastError));
    result:=false;
  end;

  Pair.SetSize(dwLen);
  bRes:=CryptExportKey(
        Key,
        expKey,
        PRIVATEKEYBLOB,
        0,
        PByte(Pair.Memory),
        @dwLen
    );
  if not bRes then
  begin
    ShowMessage('CryptExportKey private failed: '+ SysErrorMessage(GetLastError));
    result:=false;
  end;
  {
  bRes:=CryptImportKey(RSA,Pair.Memory,Pair.Size,expKey,CRYPT_EXPORTABLE,@Key);
  if not bRes then
    ShowMessage('CryptImportKey failed: '+ SysErrorMessage(GetLastError));
  }

  CryptDestroyKey(expKey);
  CryptDestroyKey(Key);
  CryptReleaseContext(RSA,0);
end;

procedure TForm3.Button1Click(Sender: TObject);
var
  i:Integer;
  s:String;

  punctuations:bool;
  numbers:bool;
  upperchars:bool;
  lowerchars:bool;

  pub,pair:TMemoryStream;
begin
  if Edit1.Text<>Edit2.Text then
  begin
    ShowMessage('Enter the same phrase in "password" and "confirm" fields');
    exit;
  end;
  for i:=1 to Length(Edit1.Text) do
  begin
    if ((Byte(Edit1.Text[i])>31) and (Byte(Edit1.Text[i])<48)) or
          ((Byte(Edit1.Text[i])>57) and (Byte(Edit1.Text[i])<65)) or
          ((Byte(Edit1.Text[i])>90) and (Byte(Edit1.Text[i])<97)) or
          ((Byte(Edit1.Text[i])>122) and (Byte(Edit1.Text[i])<127)) then
    punctuations:=true;

    if (Byte(Edit1.Text[i])>47) and (Byte(Edit1.Text[i])<58) then
      numbers:=true;

    if (Byte(Edit1.Text[i])>64) and (Byte(Edit1.Text[i])<91) then
      upperchars:=true;

    if (Byte(Edit1.Text[i])>96) and (Byte(Edit1.Text[i])<123) then
      lowerchars:=true;
  end;

  if not punctuations then s:=s+'punctuations'#10#13;
  if not numbers then s:=s+'numbers'#10#13;
  if not upperchars then s:=s+'upperchars'#10#13;
  if not lowerchars then s:=s+'lowerchars'#10#13;
  if (length(Edit1.Text)<20) or (length(Edit1.Text)>255) then
  begin
    ShowMessage('The password length must be between 20 and 255 symbols');
    exit;
  end;

  if Bool(Length(S)) then
  begin
    ShowMessage('You password doesn''t contains:'#10#13#10#13+s);
    Exit;
  end;

  if MessageBox(0, 'Confirm that you want'+
        ' to generate new public/provate key pair.'#10#13'You must know, what this act'+
        ' will make server unavailable for all your current users until they will'+
        ' not update their keys.', 'Would you like to make'+
        ' new keyset?', +mb_YesNo +mb_ICONWARNING) <> 6 then
  exit;

  pub:=TMemoryStream.Create;
  pair:=TMemoryStream.Create;
  if GenKeysPair(pub,pair,pchar(Edit1.Text),
        StrToInt(ComboBox1.Items[ComboBox1.ItemIndex])) then
  begin
    pub.SaveToFile(ExtractFilePath(paramstr(0))+'Keyset\public.rsa');
    pair.SaveToFile(ExtractFilePath(paramstr(0))+'Keyset\private.rsa');
    ShowMessage('Congratulations! Keyset is successfully generated!');
  end
  else
    ShowMessage('Warning!'#10#13'Generating keyset failed!');

  pub.Free;
  pair.Free;

  if FileExists(Dir+'Keyset\private.rsa') then
    Form4.Label2.Caption := Dir+'Keyset\private.rsa';
  if FileExists(Dir+'Keyset\public.rsa') then
    Form4.Label4.Caption := Dir+'Keyset\public.rsa';

  Form4.Label2.Width:=255;
  Form4.Label4.Width:=255;

  Edit1.Text:='';
  Edit2.Text:='';
end;

procedure TForm3.Button2Click(Sender: TObject);
begin
  Close;
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
  Dir:=ExtractFilePath(paramstr(0));
end;

end.
